open Fr
open FrGui_common

let empty =
	new static_widget ~expand: true GMisc.drawing_area


(* event generating widgets *)

let button ?enabled ?label ?icon value =
	(* NOTE: GTK 2.6+ has "image" property, but not implemented in lablgtk *)
	let widget = GButton.button () in
	begin match label, icon with
	| Some text, Some image ->
		let hbox = GPack.hbox ~packing: widget#add () in
		hbox#pack (gtk_image ~icon_size: `BUTTON image)#coerce;
		ignore (GMisc.label ~text ~packing: hbox#pack ())
	| Some text, None ->
		ignore (GMisc.label ~text ~packing: widget#add ())
	| None, Some image ->
		widget#add (gtk_image ~icon_size: `BUTTON image)#coerce
	| None, None -> ()
	end;
	let event = on (lift_signal widget#connect#clicked) () -> value in
	new simple_widget ?enabled widget, event

(* TODO: how to disable individual buttons? *)
let button_group ?enabled options =
	let widgets, events = List.split
		(List.map (fun (label, value) -> button ?enabled ~label value) options) in
	widgets, merge_e events

(* behavior generating widgets *)

let checkbox ?enabled ?label init =
	let widget = GButton.check_button ?label () in
	widget#set_active init;
	let behavior = hold widget#active
		(on (lift_signal widget#connect#toggled) () -> widget#active) in
	new simple_widget ?enabled widget, behavior

let tristate_checkbox ?enabled ?label init =
	let widget = GButton.check_button ?label () in
	begin
		match init with
		| Some init -> widget#set_active init
		| None -> widget#set_relief `NONE (*widget#set_inconsistent true*)
	end;
	let toggled = lift_signal widget#connect#toggled in
	register_e_with widget (on (once_e toggled) () -> widget#set_relief `NORMAL);
	let behavior = hold
		((*if widget#inconsistent then None else *) Some widget#active)
		(on (lift_signal widget#connect#toggled) () ->
			(*if widget#inconsistent then None else *) Some widget#active) in
	new simple_widget ?enabled widget, behavior

let toggle_button ?enabled ?label init =
	let widget = GButton.toggle_button ?label () in
	widget#set_active init;
	let behavior = hold widget#active
		(on (lift_signal widget#connect#toggled) () -> widget#active) in
	new simple_widget ?enabled widget, behavior

let tristate_toggle_button ?enabled ?label init =
	let widget = GButton.toggle_button ?label () in
	begin
		match init with
		| Some init -> widget#set_active init
		| None -> widget#set_relief `NONE (*widget#set_inconsistent true*)
	end;
	let toggled = lift_signal widget#connect#toggled in
	register_e_with widget (on (once_e toggled) () -> widget#set_relief `NORMAL);
	let behavior = hold
		((*if widget#inconsistent then None else*) Some widget#active)
		(on toggled () ->
			(*if widget#inconsistent then None else*) Some widget#active) in
	new simple_widget ?enabled widget, behavior

let radio_button_group ?enabled options init =
	assert (options <> []);
	let found_init = ref false in
	let make ?group (label, value) =
		let widget = GButton.radio_button ?group ~label () in
		if value =* init && not !found_init then
			(widget#set_active true;
			 found_init := true);
		let event = on (lift_signal widget#connect#toggled) () -> value in
		widget, event in
	let widgets, events =
		List.split
			(let first = make (List.hd options) in
			 let group = (fst first)#group in
			 first :: List.map (make ~group) (List.tl options)) in
	let init =
		if !found_init then init
		else
			((List.hd widgets)#set_active true;
			 snd (List.hd options))
	in
	List.map (new simple_widget ?enabled) widgets,
		hold init (merge_e events)

let tristate_radio_button_group ?enabled options init =
	warn "\"tristate_radio_button_group\" widget not supported in this toolkit; emulating.";
	let options' =
		List.rev (("None", None) :: List.rev_map (fun (s, v) -> s, Some v) options) in
	radio_button_group ?enabled options' init

let slider orientation ?enabled ?range ?step init =
	let lower, upper = match range with
		| Some range -> range
		| None -> 0., init *. 2. in
	let step_incr = match step with
		| Some step -> step
		| None -> (upper -. lower) /. 100. in
	let adjustment = GData.adjustment
		~lower ~upper ~step_incr ~page_size: 0. ~page_incr: step_incr ~value: init () in
	let widget = GRange.scale (gtk_orientation orientation) ~adjustment () in
	let behavior = hold init
		(on (lift_signal widget#connect#value_changed) () -> widget#adjustment#value) in
	new simple_widget ?enabled widget, behavior

let hslider = slider `Horizontal
let vslider = slider `Vertical

let text_entry ?enabled ?visible ?width init =
	let widget = GEdit.entry
		~text: init
		?width_chars: width
		~activates_default: true () in
	option_may
		(fun visible -> register_b_with widget (lift1 widget#set_visibility visible))
		visible;
	let behavior = hold init
		(on (lift_signal widget#connect#changed) () -> widget#text) in
	new simple_widget ?enabled widget, behavior

(* TODO: make sure range +-inf works
   fix page_incr
   int_spin_box *)
let spin_box ?enabled ?range ?step init =
	let lower, upper = match range with
		| Some range -> range
		| None -> 0., init *. 2. in
	let step_incr = match step with
		| Some step -> step
		| None -> (upper -. lower) /. 100. in
	let adjustment = GData.adjustment
		~lower ~upper ~step_incr ~page_size: 0. ~page_incr: step_incr ~value: init () in
	let widget = GEdit.spin_button
		~adjustment
		~numeric: true
		~update_policy: `IF_VALID
		(*~value: init*) () in
	let behavior = hold init
		(on (lift_signal widget#connect#value_changed) () -> widget#adjustment#value) in
	new simple_widget ?enabled widget, behavior

(* TODO: multiple columns *)
(* BUG: reset selection on change broken *)
let list_box ?enabled repr items init =
	let column_list = new GTree.column_list in
	(* column containing all values in list *)
	let data_column = column_list#add Gobject.Data.caml
	(* text representation of all values in list
	   this exists because we can't implement our own renderer *)
	and text_column = column_list#add Gobject.Data.string in
	let model = GTree.list_store column_list in
	let cell_renderer = GTree.cell_renderer_text [] in
	(* show the contents of text_column *)
	let view_column = GTree.view_column
		~renderer: (cell_renderer, ["text", text_column]) () in
	let widget = GBin.frame ~shadow_type: `IN () in
	let view = GTree.view
		~model
		~headers_visible: false
		~packing: widget#add
		() in
	view#selection#set_mode `MULTIPLE;
	ignore (view#append_column view_column);
	let selection_receiver, selection_event = event_receiver () in
	let selection_id =
		view#selection#connect#changed (send_event selection_receiver) in
	let selection =
		hold init
			(on selection_event () ->
				List.map
					(fun row -> model#get
						~row: (model#get_iter row)
						~column: data_column)
					view#selection#get_selected_rows)
			in
	let items_changes = merge_e [changesq items; snapshot_b items now] in
	register_e_with view (lift begin
		(* Q: does selection get "changed" here?
		   A: no, it doesn't, but we need to force it to anyway
		      or else it won't get cleared properly 
		      also, we can use misc#handler_block to temporarily block the signal *)
		view#selection#misc#handler_block selection_id;
		view#selection#unselect_all ();
		view#set_model None;
		model#clear ();
		List.iter (fun v ->
			let row = model#append () in
			model#set row data_column v;
			model#set row text_column (repr v)) %items_changes;
		view#set_model (Some (model :> GTree.model));
		(* This is O(n^2), how can we fix it? *)
		List.iter (fun v ->
				(* BUG: emits multiple select signals *)
				model#foreach (fun path iter ->
					if not (view#selection#iter_is_selected iter)
					&& model#get ~row: iter ~column: data_column =* v then
						(view#selection#select_iter iter; true)
					else false)
			) @selection;
		view#selection#misc#handler_unblock selection_id
	end);
	object
		(* view is what we want enabled/disabled, not frame *)
		inherit simple_widget ?enabled view
		method widget = (widget :> GObj.widget)
	end, selection

let combo_box ?enabled ?columns repr items init =
	assert (items <> []);
	let column_list = new GTree.column_list in
	(* column containing all values in list *)
	let data_column = column_list#add Gobject.Data.caml
	(* text representation of all values in list
	   this exists because we can't implement our own renderer *)
	and text_column = column_list#add Gobject.Data.string in
	let model = GTree.list_store column_list in
	List.iter (fun v ->
		let row = model#append () in
		model#set row data_column v;
		model#set row text_column (repr v)) items;
	let cell_renderer = GTree.cell_renderer_text [] in
	(* show the contents of text_column *)
	let widget = GEdit.combo_box ~model ?wrap_width: columns () in
	widget#pack cell_renderer;
	widget#add_attribute cell_renderer "text" text_column;
	let found_init = ref false in
	model#foreach (fun path iter ->
		if model#get ~row: iter ~column: data_column =* init then
			(widget#set_active_iter (Some iter); found_init := true; true)
		else false);
	let init =
		if !found_init then init
		else
			(widget#set_active_iter model#get_iter_first;
			List.hd items) in
	let selection =
		hold init
			(on (lift_signal widget#connect#changed) () ->
				match widget#active_iter with
				(* AFAIK GTK provides no way of unselecting an item in a combo box *)
				| None -> assert false
				| Some iter -> model#get ~row: iter ~column: data_column)
			in
	new simple_widget ?enabled widget, selection

let combo_box_entry ?enabled ?columns ?(autocomplete=true) items init =
	let column_list = new GTree.column_list in
	let text_column = column_list#add Gobject.Data.string in
	let model = GTree.list_store column_list in
	List.iter (fun v ->
		let row = model#append () in
		model#set row text_column v) items;
	let widget = GEdit.combo_box_entry ~model ~text_column ?wrap_width: columns () in
	widget#entry#set_text init;
	
	if autocomplete then begin
		let entry_completion = GEdit.entry_completion ~model ~entry: widget#entry () in
		(* TODO: #set_inline_completion true; #set_popup_single_match false (both 2.6 only) *)
		entry_completion#set_text_column text_column
	end;
	
	let selection = hold init
		(on (lift_signal widget#connect#changed) () -> widget#entry#text) in
	new simple_widget ?enabled widget, selection


(* event watching widgets *)

let progress_ticker ?text pulse =
	let widget = GRange.progress_bar () in
	register_e_with widget (on pulse -> widget#pulse);
	option_may
		(fun text -> register_b_with widget (lift1 widget#set_text text))
		text;
	new simple_widget widget

let log_area text =
	let buffer = GText.buffer () in
	let widget = GBin.scrolled_window ~shadow_type: `IN ~hpolicy: `AUTOMATIC () in
	let view = GText.view
		~buffer
		~editable: false
		~wrap_mode: `WORD
		~packing: widget#add () in
	let base_color = `COLOR (view#misc#style#base `INSENSITIVE) in
	view#misc#modify_base [
		`ACTIVE, base_color;
		`NORMAL, base_color;
		`PRELIGHT, base_color ];
	register_e_with widget (lift begin
		if buffer#char_count > 0 then buffer#insert ~iter: buffer#end_iter "\n";
		buffer#insert ~iter: buffer#end_iter %text
	end);
	new simple_widget ~expand: true widget


(* behavior watching widgets *)

let label ?justification ?selectable text =
	new static_widget (GMisc.label
		?justify: (option_map gtk_justification justification)
		?selectable
		~text)

let image_label image =
	new static_widget (fun () -> gtk_image image)

let text_view ?width text =
	let widget = GEdit.entry ~editable: false ?width_chars: width () in
	let base_color = `COLOR (widget#misc#style#base `INSENSITIVE) in
	widget#misc#modify_base [
		`ACTIVE, base_color;
		`NORMAL, base_color;
		`PRELIGHT, base_color ];
	new behavior_view_widget widget widget#set_text text

(* TODO: justification, wrapping?
   should monospaced be a behavior? *)
let text_area_view ?(monospaced=false) text =
	let buffer = GText.buffer () in
	let widget = GBin.frame ~shadow_type: `IN () in
	let view = GText.view
		~buffer
		~editable: false
		~packing: widget#add () in
	let base_color = `COLOR (view#misc#style#base `INSENSITIVE) in
	view#misc#modify_base [
		`ACTIVE, base_color;
		`NORMAL, base_color;
		`PRELIGHT, base_color ];
	if monospaced then
		view#misc#modify_font_by_name "Monospace";
	new behavior_view_widget widget buffer#set_text text

let progress_bar ?text fraction =
	let widget = GRange.progress_bar () in
	register_b_with widget (lift (widget#set_fraction (max 0. (min 1. @fraction))));
	option_may
		(fun text -> register_b_with widget (lift1 widget#set_text text))
		text;
	new simple_widget widget
	